home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 19 / madtrb40.zip / LORES.PAS < prev    next >
Pascal/Delphi Source File  |  1986-03-22  |  4KB  |  175 lines
  1. {
  2. **************************************************************************
  3. *                      Low Resolution Graphics                           *
  4. *                                                                        *
  5. *                      Richard Chandler  Raliegh, NC                     *
  6. *                      PC World March 1986 pg. 305                       *
  7. *                                                                        *
  8. **************************************************************************
  9. }
  10. Program Lo_Res_Graphics;
  11. type
  12.   scr     =     array[1..16000] of byte;
  13.   color   =     array[0..7] of byte;
  14. const
  15.   blue    :     color  =  (1,16,9,24,18,51,26,110);
  16.   green   :     color  =  (2,37,31,10,39,102,85,115);
  17.   cyan    :     color  =  (17,32,25,52,94,86,116,125);
  18.   red     :     color  =  (4,58,62,12,66,126,131,132);
  19.   magenta :     color  =  (5,19,73,59,71,27,78,130);
  20.   brown   :     color  =  (6,81,83,41,87,68,128,133);
  21.   gray    :     color  =  (0,8,100,7,92,107,90,135);
  22.  
  23. var
  24.   i,j,k,l   :   byte;
  25.   stop      :   char;
  26.   screen    :   scr  absolute $B800:$0000;
  27.   color_table  :  array[0..135,0..1] of byte;
  28.  
  29. {----- Set Graphics Controller Chip for Lo-Res -----}
  30.  
  31. Procedure Set_Lo_Res;
  32. type
  33.   reg   =  array[0..11] of byte;
  34. const
  35.   modereg   =  $03D8;
  36.   colorreg  =  $03D9;
  37.   crtreg    =  $03D4;
  38.   crtdata   =  $03D5;
  39.   regdata   :  reg  = (113,80,90,10,127,6,100,112,2,1,32,0);
  40.  
  41. var
  42.   i    :  byte;
  43.   j    :  integer;
  44.   modesave  :  byte absolute $0000:$0465;
  45.   colorsave :  byte absolute $0000:$0466;
  46. begin
  47.   modesave  := 0;
  48.   port[modereg] := 0;
  49.   colorsave := 0;
  50.   port[colorreg] := 0;
  51.   for i := 0 to 11 do
  52.   begin
  53.     port[crtreg] := i;
  54.     port[crtdata] := regdata[i];
  55.   end;
  56.   for j := i to 16000 do
  57.   begin
  58.     screen[j] := 177;
  59.     j := j+1;
  60.     screen[j] := 0;
  61.   end;
  62.   modesave := 9;
  63.   port[modereg] := 9;
  64.   end;
  65.  
  66. {----- Restore Text Screen -----}
  67.  
  68. Procedure Set_Text_Mode;
  69. type
  70.   reg            =  array[0..11] of byte;
  71. const
  72.   crtreg         =  $03D4;
  73.   crtdata        =  $03D5;
  74.   regdata        : reg = (113,80,90,10,31,6,25,28,2,7,6,7);
  75. var
  76.   i   :  byte;
  77. begin
  78.   for i := 0 to 11 do
  79.   begin
  80.     port[crtreg] := i;
  81.     port[crtdata] := regdata[i];
  82.   end;
  83.   textmode(3);
  84.   ClrScr;
  85. end;
  86.  
  87. {----- Clears Screen -----}
  88.  
  89. Procedure Clear_Screen;
  90. var
  91.   i  :  integer;
  92. begin
  93.   for i := 1 to 16000 do
  94.   begin
  95.     i := i + 1;
  96.     screen[i] := 0;
  97.   end;
  98. end;
  99.  
  100. {----- Set Color Table -----}
  101.  
  102. Procedure Set_Colors;
  103. var
  104.   i,c,fg,bg  : byte;
  105. begin
  106.   c := 0;
  107.   for i := 0 to 255 do
  108.   begin
  109.     bg := i div 16;
  110.     fg := i mod 16;
  111.     if bg <= fg then
  112.     begin
  113.       color_table[c,0] := bg;
  114.       color_table[c,1] := fg;
  115.       c := c+1;
  116.     end;
  117.   end;
  118. end;
  119.  
  120. {----- Plots Point(x,y) in color bg/fg -----}
  121.  
  122. Procedure Point(x,y,c:integer);
  123. var
  124.   bg,fg  :  integer;
  125. begin
  126.   bg := color_table[c,0];
  127.   fg := color_table[c,1];
  128.   screen[2*(x+1)+160*y] := fg + bg * 16;
  129. end;
  130.  
  131. {----- Display colors in sequence -----}
  132.  
  133. Procedure Display_All_Colors;
  134. var
  135.   i,j,k,l  :  integer;
  136. begin
  137.   for i := 0 to 16 do
  138.     for j := 0 to 7 do
  139.       for k := 0 to 3 do
  140.         for l := 0 to 11 do
  141.           Point(i*4+k,j*12+l,8*i+j);
  142. end;
  143.  
  144. {----- Display selected Palette -----}
  145.  
  146. Procedure Display_Palette;
  147. var
  148.   i,j,k  :  integer;
  149. begin
  150.   for i := 0 to 7 do
  151.     for j := 0 to 3 do
  152.       for k := 0 to 11 do
  153.       begin
  154.         Point(4*i+j,k,blue[i]);
  155.         Point(4*i+j,k+12,green[i]);
  156.         Point(4*i+j,k+24,cyan[i]);
  157.         Point(4*i+j,k+36,red[i]);
  158.         Point(4*i+j,k+48,magenta[i]);
  159.         Point(4*i+j,k+60,brown[i]);
  160.         Point(4*i+j,k+72,gray[i]);
  161.       end;
  162. end;
  163.  
  164. {----- Main Program Begins Here -----}
  165.  
  166. Begin
  167.   Set_Lo_Res;
  168.   Set_Colors;
  169.   Display_All_Colors;
  170.   read(kbd, stop);
  171.   clear_screen;
  172.   Display_Palette;
  173.   read(kbd,stop);
  174.   Set_text_mode;
  175. end.